Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue58/EasyWeb/WebCtrls.pas

Pascal/Delphi Source File | 2000-03-30 | 21.1 KB | 780 lines

{ *****************************************************
              TWebControls Components

  These Components allow the developer to use visual
  components on WebBroker forms.

                  Paul Warren
         HomeGrown Software Development
       (c) 1997 Langley British Columbia.
                [phone]
         e-mail:  [e-mail]
    Home page: http://users.uniserve.com/~hg_soft
  ***************************************************** }

unit WebCtrls;

interface

uses
  Windows, SysUtils, Messages, Classes, Controls, Graphics, Charts, EnhCalnd,
  XLabel, Grids, StdCtrls;

type
  TWebControl = class(TComponent)
  private
    { Private declarations }
    FWidth: integer;
    FHeight: integer;
    FContentType: string;
    FControl: TControl;
    function GetContentAsStream: TStream; virtual; abstract;
    procedure SetOutput(Value: TBitmap); virtual;
    function GetOutput: TBitmap; virtual;
    procedure SetHeight(Value: integer);
    procedure SetWidth(Value: integer);
  protected
    { Protected declarations }
  public
    { Public declarations }
    property ContentAsStream: TStream read GetContentAsStream;
    property ContentType: string read FContentType write FContentType;
    property Width: integer read FWidth write SetWidth default 200;
    property Height: integer read FHeight write SetHeight default 150;
  published
    { Published declarations }
    property Output: TBitmap read GetOutput write SetOutput stored false;
  end;

  TWebWinControl = class(TWebControl)
  private
    { Private declarations }
    function GetContentAsStream: TStream; override;
    function GetOutput: TBitmap; override;
  protected
    { Protected declarations }
  public
    { Public declarations }
  published
    { Published declarations }
  end;

  TWebChart = class(TWebControl)
  private
    { Private declarations }
    function GetContentAsStream: TStream; override;
    procedure SetTitle(Value: TTitleStr);
    procedure SetBorderWidth(Value: integer);
    function GetTitle: TTitleStr;
    function GetBorderWidth: integer;
  protected
    { Protected declarations }
  public
    { Public declarations }
    procedure ClearData; virtual; abstract;
  published
    { Published declarations }
    property Title: TTitleStr read GetTitle write SetTitle;
    property BorderWidth: integer read GetBorderWidth write SetBorderWidth;
    property ContentType;
    property Width;
    property Height;
  end;

  TWebXYChart = class(TWebChart)
  private
    { Private declarations }
    FOnNeedLinesX: TNeedLines;
    FOnNeedLinesY: TNeedLines;
    FOnScaling: TScaling;
    FOnDrawScales: TDrawScales;
    procedure SetXLabel(Value: TTitleStr);
    procedure SetYLabel(Value: TTitleStr);
    procedure SetGrid(Value: TGridType);
    procedure SetChartType(Value: TChartType);
    function GetChartType: TChartType;
    function GetXLabel: TTitleStr;
    function GetYLabel: TTitleStr;
    function GetGrid: TGridType;
    function GetOutput: TBitmap; override;
  protected
    { Protected declarations }
    procedure DoNeedLinesX(Sender: TObject; var Value: Double; var AColor: TColor; var Finished: boolean);
    procedure DoNeedLinesY(Sender: TObject; var Value: Double; var AColor: TColor; var Finished: boolean);
    procedure DoScaling(Sender: TObject; var MinX, MaxX, MinY, MaxY: Double);
    procedure DoDrawScales(Sender: TObject; Axis: TAxisType; Data: Double; var DataText: string);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddData(X, Y: Double);
    procedure ClearData; override;
  published
    { Published declarations }
    property ChartType: TChartType read GetChartType write SetChartType;
    property XLabel: TTitleStr read GetXLabel write SetXLabel;
    property YLabel: TTitleStr read GetYLabel write SetYLabel;
    property Grid: TGridType read GetGrid write SetGrid;
    property OnNeedLinesX: TNeedLines read FOnNeedLinesX write FOnNeedLinesX;
    property OnNeedLinesY: TNeedLines read FOnNeedLinesY write FOnNeedLinesY;
    property OnScaling: TScaling read FOnScaling write FOnScaling;
    property OnDrawScales: TDrawScales read FOnDrawScales write FOnDrawScales;
  end;

  TWebPieChart = class(TWebChart)
  private
    { Private declarations }
    FOnDrawPie: TDrawPie;
    FOnDrawLabel: TDrawLabel;
    procedure SetXLabel(Value: TTitleStr);
    procedure SetUseLabels(Value: boolean);
    function GetUseLabels: boolean;
    function GetXLabel: TTitleStr;
    function GetOutput: TBitmap; override;
  protected
    { Protected declarations }
    procedure DoDrawPie(Sender: TObject; var Color: TColor);
    procedure DoDrawLabel(Sender: TObject; Data, DataSum: Double; var DataText: string);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddData(X: Double; Y: string);
    procedure ClearData; override;
  published
    { Published declarations }
    property XLabel: TTitleStr read GetXLabel write SetXLabel;
    property UseLabels: boolean read GetUseLabels write SetUseLabels default true;
    property OnDrawPie: TDrawPie read FOnDrawPie write FOnDrawPie;
    property OnDrawLabel: TDrawLabel read FOnDrawLabel write FOnDrawLabel;
  end;

  TRotatedLabel = class(TXLabel)
  public
    { Public declarations }
    procedure PaintTo(DC: HDC; X, Y: Integer);
  end;

  TWebRotatedLabel = class(TWebControl)
  private
    { Private declarations }
    function GetContentAsStream: TStream; override;
    function GetAngle: integer;
    function GetRelief: boolean;
    function GetColor: TColor;
    function GetCaption: string;
    function GetFont: TFont;
    procedure SetAngle(Value: integer);
    procedure SetRelief(Value: Boolean);
    procedure SetColor(Value: TColor);
    procedure SetCaption(Value: string);
    procedure SetFont(Value: TFont);
    function GetOutput: TBitmap; override;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Angle: Integer read GetAngle write SetAngle;
    property Relief: Boolean read GetRelief write SetRelief;
    property Color: TColor read GetColor write SetColor;
    property Caption: string read GetCaption write SetCaption;
    property Font: TFont read GetFont write SetFont;
    property ContentType;
    property Width;
    property Height;
  end;

  TWebCalendar = class(TWebWinControl)
  private
    { Private declarations }
    FOnNeedStrings: TNeedStrings;
    function GetBlockWeekends: boolean;
    function GetBlockedColor: TColor;
    function GetFixedHeader: boolean;
    function GetRangeColor: TColor;
    function GetStartDate: TDateTime;
    function GetEndDate: TDateTime;
    function GetCalendarDate: TDateTime;
    procedure SetBlockWeekends(Value: Boolean);
    procedure SetBlockedColor(Value: TColor);
    procedure SetCalendarDate(Value: TDateTime);
    procedure SetFixedHeader(Value: Boolean);
    procedure SetRangeColor(Value: TColor);
    procedure SetStartDate(Value: TDateTime);
    procedure SetEndDate(Value: TDateTime);
  protected
    { Protected declarations }
    procedure DoNeedStrings(Sender: TObject; ACol, ARow: Integer; ADate: TDateTime; var Value: TStringList);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property BlockWeekends: Boolean read GetBlockWeekends write SetBlockWeekends default false;
    property BlockedColor: TColor read GetBlockedColor write SetBlockedColor default clGray;
    property CalendarDate: TDateTime read GetCalendarDate write SetCalendarDate stored false;
    property FixedHeader: Boolean read GetFixedHeader write SetFixedHeader default True;
    property RangeColor: TColor read GetRangeColor write SetRangeColor default clBlue;
    property StartDate: TDateTime read GetStartDate write SetStartDate;
    property EndDate: TDateTime read GetEndDate write SetEndDate;
    property OnNeedStrings: TNeedStrings read FOnNeedStrings write FOnNeedStrings;
    property Width;
    property Height;
    property ContentType;
  end;

procedure Register;

implementation

uses JPeg, Forms;

{ TWebControl }
procedure TWebControl.SetHeight(Value: integer);
begin
  // make sure to change the control properties when
  // changing the components properties
  if Value <> FHeight then
  begin
    FHeight := Value;
    FControl.Height := FHeight;
  end;
end;

procedure TWebControl.SetWidth(Value: integer);
begin
  // make sure to change the control properties when
  // changing the components properties
  if Value <> FWidth then
  begin
    FWidth := Value;
    FControl.Width := FWidth;
  end;
end;

procedure TWebControl.SetOutput(Value: TBitmap);
begin
  // do nothing
end;

function TWebControl.GetOutput: TBitmap;
begin
  Result := TBitmap.Create;
end;

{ TWebWinControl }
function TWebWinControl.GetOutput: TBitmap;
var
  Dummy: TForm;
begin
  Result := inherited GetOutput;
  try
    Dummy := TForm.Create(nil);
    try
      FControl.Parent := Dummy;
      Result.Width := FControl.Width;
      Result.Height := FControl.Height;
      Result.Canvas.Lock;
      try
        (FControl as TWinControl).PaintTo(Result.Canvas.Handle, 0, 0);
        //Result.Assign((FControl as TRngSelCalendar).PaintTo(Result.Canvas.Handle, 0, 0));
      finally
        Result.Canvas.Unlock;
      end;
    finally
      FControl.Parent := nil;
      Dummy.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;

function TWebWinControl.GetContentAsStream: TStream;
var
  Dummy: TForm;
  Jpg: TJpegImage;
begin
  Result := TMemoryStream.Create;
  try
    Dummy := TForm.Create(nil);
    try
      FControl.Parent := Dummy;
      Jpg := TJpegImage.Create;
      try
        Jpg.Assign(Output);
        Jpg.SaveToStream(Result);
        Result.Position := 0;
      finally
        Jpg.Free;
      end;
    finally
      FControl.Parent := nil;
      Dummy.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;

{ TWebChart }
function TWebChart.GetContentAsStream: TStream;
var
  Jpg: TJpegImage;
  S: TMemoryStream;
begin
  Jpg := TJpegImage.Create;
  try
    Jpg.Assign(Output);
    S := TMemoryStream.Create;
    Jpg.SaveToStream(S);
    S.Position := 0;
    Result := S;
  finally
    Jpg.Free;
  end;
end;

procedure TWebChart.SetTitle(Value: TTitleStr);
begin
  (FControl as ThgCustomChart).Title := Value;
end;

procedure TWebChart.SetBorderWidth(Value: integer);
begin
  (FControl as ThgCustomChart).BorderWidth := Value;
end;

function TWebChart.GetTitle: TTitleStr;
begin
  Result := (FControl as ThgCustomChart).Title;
end;

function TWebChart.GetBorderWidth: integer;
begin
  Result := (FControl as ThgCustomChart).BorderWidth;
end;

{ TWebXYChart }
constructor TWebXYChart.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // set default properties
  FContentType := 'image/jpeg';
  FWidth := 200;
  FHeight := 150;
  // create underlying chart
  FControl := TXYChart.Create(nil);
  // set chart properties
  FControl.Width := FWidth;
  FControl.Height := FHeight;
  (FControl as TXYChart).OnNeedLinesX := DoNeedLinesX;
  (FControl as TXYChart).OnNeedLinesY := DoNeedLinesY;
  (FControl as TXYChart).OnScaling := DoScaling;
  (FControl as TXYChart).OnDrawScales := DoDrawScales;
end;

destructor TWebXYChart.Destroy;
begin
  // free chart
  FControl.Free;
  inherited Destroy;
end;

function TWebXYChart.GetOutput: TBitmap;
var
  i: integer;
begin
  if csDesigning in ComponentState then
  begin
    ClearData;
    for i := 1 to 10 do AddData(i, i*2);
  end;
  Result := inherited GetOutput;
  try
    Result.Assign((FControl as ThgCustomChart).GetComponentImage);
  except
    Result.Free;
    raise;
  end;
end;

procedure TWebXYChart.AddData(X, Y: Double);
begin
  // pass data through to chart
  (FControl as TXYChart).AddData(X, Y);
end;

procedure TWebXYChart.ClearData;
begin
  (FControl as TXYChart).ClearData;
end;

procedure TWebXYChart.DoNeedLinesX(Sender: TObject; var Value: Double; var AColor: TColor; var Finished: boolean);
begin
  if Assigned(FOnNeedLinesX) then FOnNeedLinesX(Sender, Value, AColor, Finished);
end;

procedure TWebXYChart.DoNeedLinesY(Sender: TObject; var Value: Double; var AColor: TColor; var Finished: boolean);
begin
  if Assigned(FOnNeedLinesY) then FOnNeedLinesY(Sender, Value, AColor, Finished);
end;

procedure TWebXYChart.DoScaling(Sender: TObject; var MinX, MaxX, MinY, MaxY: Double);
begin
  if Assigned(FOnScaling) then FOnScaling(Sender, MinX, MaxX, MinY, MaxY);
end;

procedure TWebXYChart.DoDrawScales(Sender: TObject; Axis: TAxisType; Data: Double; var DataText: string);
begin
  if Assigned(FOnDrawScales) then FOnDrawScales(Sender, Axis, Data, DataText);
end;

procedure TWebXYChart.SetXLabel(Value: TTitleStr);
begin
  (FControl as TXYChart).XLabel := Value;
end;

procedure TWebXYChart.SetYLabel(Value: TTitleStr);
begin
  (FControl as TXYChart).YLabel := Value;
end;

procedure TWebXYChart.SetGrid(Value: TGridType);
begin
  (FControl as TXYChart).Grid := Value;
end;

procedure TWebXYChart.SetChartType(Value: TChartType);
begin
  (FControl as TXYChart).ChartType := Value;
end;

function TWebXYChart.GetChartType: TChartType;
begin
  Result := (FControl as TXYChart).ChartType;
end;

function TWebXYChart.GetXLabel: TTitleStr;
begin
  Result := (FControl as TXYChart).XLabel;
end;

function TWebXYChart.GetYLabel: TTitleStr;
begin
  Result := (FControl as TXYChart).YLabel;
end;

function TWebXYChart.GetGrid: TGridType;
begin
  Result := (FControl as TXYChart).Grid;
end;

{ TWebPieChart }
constructor TWebPieChart.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // set default properties
  FContentType := 'image/jpeg';
  FWidth := 200;
  FHeight := 150;
  // create underlying chart
  FControl := TPieChart.Create(nil);
  // set chart properties
  FControl.Width := FWidth;
  FControl.Height := FHeight;
  (FControl as TPieChart).OnDrawPie := DoDrawPie;
  (FControl as TPieChart).OnDrawLabel := DoDrawLabel;
end;

destructor TWebPieChart.Destroy;
begin
  // free chart
  FControl.Free;
  inherited Destroy;
end;

function TWebPieChart.GetOutput: TBitmap;
var
  i: integer;
begin
  ClearData;
  for i := 1 to 6 do
    AddData(i*i, 'Data Point '+IntToStr(i));
  Result := inherited GetOutput;
  try
    Result.Assign((FControl as ThgCustomChart).GetComponentImage);
  except
    Result.Free;
    raise;
  end;
end;

procedure TWebPieChart.AddData(X: Double; Y: string);
begin
  // pass data through to chart
  (FControl as TPieChart).AddData(X, Y);
end;

procedure TWebPieChart.ClearData;
begin
  (FControl as TPieChart).ClearData;
end;

procedure TWebPieChart.DoDrawPie(Sender: TObject; var Color: TColor);
begin
  if Assigned(FOnDrawPie) then FOnDrawPie(Sender, Color);
end;

procedure TWebPieChart.DoDrawLabel(Sender: TObject; Data, DataSum: Double; var DataText: string);
begin
  if Assigned(FOnDrawLabel) then FOnDrawLabel(Sender, Data, DataSum, DataText);
end;

procedure TWebPieChart.SetXLabel(Value: TTitleStr);
begin
  (FControl as ThgCustomChart).XLabel := Value;
end;

procedure TWebPieChart.SetUseLabels(Value: boolean);
begin
  (FControl as TPieChart).UseLabels := Value;
end;

function TWebPieChart.GetUseLabels: boolean;
begin
  Result := (FControl as TPieChart).UseLabels;
end;

function TWebPieChart.GetXLabel: TTitleStr;
begin
  Result := (FControl as ThgCustomChart).XLabel;
end;

{ TRotatedLabel - PaintTo method }
procedure TRotatedLabel.PaintTo(DC: HDC; X, Y: Integer);
var
  SaveIndex: Integer;
begin
  SaveIndex := SaveDC(DC);
  MoveWindowOrg(DC, X, Y);
  IntersectClipRect(DC, 0, 0, Width, Height);
  Perform(WM_ERASEBKGND, DC, 0);
  Perform(WM_PAINT, DC, 0);
  RestoreDC(DC, SaveIndex);
end;

{ TWebChart }
constructor TWebRotatedLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // set default properties
  FContentType := 'image/jpeg';
  FWidth := 200;
  FHeight := 150;
  // create underlying control
  FControl := TRotatedLabel.Create(nil);
  // set label properties
  FControl.Width := FWidth;
  FControl.Height := FHeight;
  (FControl as TRotatedLabel).Caption := 'Rotating Label';
end;

destructor TWebRotatedLabel.Destroy;
begin
  // free control
  FControl.Free;
  inherited Destroy;
end;

function TWebRotatedLabel.GetOutput: TBitmap;
begin
  Result := inherited GetOutput;
  try
    Result.Width := FControl.Width;
    Result.Height := FControl.Height;
    Result.Canvas.Lock;
    try
      (FControl as TRotatedLabel).PaintTo(Result.Canvas.Handle, 0, 0);
    finally
      Result.Canvas.Unlock;
    end;
  except
    Result.Free;
    raise;
  end;
end;

function TWebRotatedLabel.GetContentAsStream: TStream;
var
  Jpg: TJpegImage;
  S: TMemoryStream;
begin
  Jpg := TJpegImage.Create;
  try
    Jpg.Assign(Output);
    S := TMemoryStream.Create;
    Jpg.SaveToStream(S);
    S.Position := 0;
    Result := S;
  finally
    Jpg.Free;
  end;
end;

function TWebRotatedLabel.GetAngle: integer;
begin
  Result := (FControl as TRotatedLabel).Angle;
end;

function TWebRotatedLabel.GetRelief: boolean;
begin
  Result := (FControl as TRotatedLabel).Relief;
end;

function TWebRotatedLabel.GetColor: TColor;
begin
  Result := (FControl as TRotatedLabel).Color;
end;

function TWebRotatedLabel.GetCaption: string;
begin
  Result := (FControl as TRotatedLabel).Caption;
end;

function TWebRotatedLabel.GetFont: TFont;
begin
  Result := (FControl as TRotatedLabel).Font;
end;

procedure TWebRotatedLabel.SetAngle(Value: integer);
begin
  (FControl as TRotatedLabel).Angle := Value;
end;

procedure TWebRotatedLabel.SetRelief(Value: boolean);
begin
  (FControl as TRotatedLabel).Relief := Value;
end;

procedure TWebRotatedLabel.SetColor(Value: TColor);
begin
  (FControl as TRotatedLabel).Color := Value;
end;

procedure TWebRotatedLabel.SetCaption(Value: string);
begin
  (FControl as TRotatedLabel).Caption := Value;
end;

procedure TWebRotatedLabel.SetFont(Value: TFont);
begin
  (FControl as TRotatedLabel).Font := Value;
end;

{ TWebCalendar }
constructor TWebCalendar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // set default properties
  FContentType := 'image/jpeg';
  FWidth := 200;
  FHeight := 150;
  // create underlying calendar
  FControl := TRngSelCalendar.Create(nil);
  // set calendar properties
  FControl.Width := FWidth;
  FControl.Height := FHeight;
  (FControl as TRngSelCalendar).OnNeedStrings := DoNeedStrings;
end;

destructor TWebCalendar.Destroy;
begin
  // free calendar
  FControl.Free;
  inherited Destroy;
end;

procedure TWebCalendar.DoNeedStrings(Sender: TObject; ACol,
            ARow: Integer; ADate: TDateTime; var Value: TStringList);
begin
  if Assigned(FOnNeedStrings) then FOnNeedStrings(Sender, ACol, ARow, ADate, Value);
end;

function TWebCalendar.GetBlockWeekends: boolean;
begin
  Result := (FControl as TRngSelCalendar).BlockWeekends;
end;

function TWebCalendar.GetBlockedColor: TColor;
begin
  Result := (FControl as TRngSelCalendar).BlockedColor;
end;

function TWebCalendar.GetFixedHeader: boolean;
begin
  Result := (FControl as TRngSelCalendar).FixedHeader;
end;

function TWebCalendar.GetRangeColor: TColor;
begin
  Result := (FControl as TRngSelCalendar).RangeColor;
end;

function TWebCalendar.GetCalendarDate: TDateTime;
begin
  Result := (FControl as TRngSelCalendar).CalendarDate;
end;

function TWebCalendar.GetStartDate: TDateTime;
begin
  Result := (FControl as TRngSelCalendar).StartDate;
end;

function TWebCalendar.GetEndDate: TDateTime;
begin
  Result := (FControl as TRngSelCalendar).EndDate;
end;

procedure TWebCalendar.SetFixedHeader(Value: Boolean);
begin
  (FControl as TRngSelCalendar).FixedHeader := Value;
end;

procedure TWebCalendar.SetBlockWeekends(Value: Boolean);
begin
  (FControl as TRngSelCalendar).BlockWeekends := Value;
end;

procedure TWebCalendar.SetBlockedColor(Value: TColor);
begin
  (FControl as TRngSelCalendar).BlockedColor := Value;
end;

procedure TWebCalendar.SetCalendarDate(Value: TDateTime);
begin
  (FControl as TRngSelCalendar).CalendarDate := Value;
end;

procedure TWebCalendar.SetRangeColor(Value: TColor);
begin
  (FControl as TRngSelCalendar).RangeColor := Value;
end;

procedure TWebCalendar.SetStartDate(Value: TDateTime);
begin
  (FControl as TRngSelCalendar).StartDate := Value;
end;

procedure TWebCalendar.SetEndDate(Value: TDateTime);
begin
  (FControl as TRngSelCalendar).EndDate := Value;
end;

procedure Register;
begin
  RegisterComponents('Internet', [TWebXYChart]);
  RegisterComponents('Internet', [TWebPieChart]);
  RegisterComponents('Internet', [TWebRotatedLabel]);
  RegisterComponents('Internet', [TWebCalendar]);
end;

end.